home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gnat1792.zip
/
gnat179b
/
t-adainc
/
i-cstrin.adb
< prev
next >
Wrap
Text File
|
1994-05-19
|
7KB
|
271 lines
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S . C . S T R I N G S --
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
package body Interfaces.C.Strings is
-----------------------
-- Local Subprograms --
-----------------------
package Char_Access is new Address_To_Access_Conversions (Char);
function Peek (From : Chars_Ptr) return Char;
pragma Inline (Peek);
-- Given a Chars_Ptr value, obtain referenced character
procedure Poke (Value : Char; Into : Chars_Ptr);
pragma Inline (Poke);
-- Given a Chars_Ptr, modify referenced Character value
function "+" (Left : Chars_Ptr; Right : Integer) return Chars_Ptr;
pragma Inline ("+");
-- Address arithmetic on Chars_Ptr value
No_Nul_Found : constant Integer := -1;
function Position_Of_Nul (Into : Char_Array) return Integer;
-- Returns position of the first Nul in Into or No_Nul_Found (-1) if none.
function C_Malloc (Size : Positive) return Chars_Ptr;
pragma Import (C, C_Malloc, "malloc");
procedure C_Free (Address : Chars_Ptr);
pragma Import (C, C_Free, "free");
---------
-- "+" --
---------
function "+" (Left : Chars_Ptr; Right : Integer) return Chars_Ptr is
begin
return Left + Chars_Ptr (Right);
end "+";
--------------------
-- Allocate_Chars --
--------------------
function Allocate_Chars (Chars : in Char_Array) return Chars_Ptr is
Index : Integer;
begin
Index := Position_Of_Nul (Into => Chars);
if Index = No_Nul_Found then
Index := Chars'Last;
else
Index := Index - 1; -- Index may become -1; It's OK.
end if;
-- Returned value is length of signficant part + 1 for the nul character
return C_Malloc ((Index - Chars'First + 1) + 1);
end Allocate_Chars;
---------------------
-- Allocate_String --
---------------------
function Allocate_String (Str : in String) return Chars_Ptr is
begin
return Allocate_Chars (To_C (Str));
end Allocate_String;
----------
-- Free --
----------
procedure Free (Item : in out Chars_Ptr) is
begin
if Item = Null_Ptr then
return;
end if;
C_Free (Item);
Item := Null_Ptr;
end Free;
----------
-- Peek --
----------
function Peek (From : Chars_Ptr) return Char is
use Char_Access;
begin
return To_Pointer (Address (To_Address (From))).all;
end Peek;
----------
-- Poke --
----------
procedure Poke (Value : Char; Into : Chars_Ptr) is
use Char_Access;
begin
To_Pointer (Address (To_Address (Into))).all := Value;
end Poke;
---------------------
-- Position_Of_Nul --
---------------------
function Position_Of_Nul (Into : Char_Array) return Integer is
begin
for J in Into'range loop
if Into (J) = Nul then
return J;
end if;
end loop;
return No_Nul_Found;
end Position_Of_Nul;
------------
-- Strlen --
------------
function Strlen (Item : in Chars_Ptr) return Natural is
Item_Index : Natural := 0;
begin
loop
if Peek (Item + Item_Index) = Nul then
return Item_Index;
end if;
Item_Index := Item_Index + 1;
end loop;
end Strlen;
------------------
-- To_Chars_Ptr --
------------------
function To_Chars_Ptr
(Item : Char_Array_Ptr;
Null_Check : in Boolean := False)
return Chars_Ptr
is
begin
if Item = null then
return Null_Ptr;
elsif Null_Check and then
Position_Of_Nul (Into => Item.all) = No_Nul_Found
then
raise Unterminated;
else
return To_Integer (Item (Item'First)'Address);
end if;
end To_Chars_Ptr;
------------
-- Update --
------------
procedure Update
(Item : in Chars_Ptr;
Offset : in Natural;
Chars : in Char_Array;
Check : Boolean := True)
is
Index : Chars_Ptr := Item + Offset;
begin
if Check and then Offset + Chars'Length > Strlen (Item) then
raise Update_Error;
end if;
for J in Chars'range loop
Poke (Chars (J), Into => Index);
Index := Index + 1;
end loop;
end Update;
procedure Update
(Item : in Chars_Ptr;
Offset : in Natural;
Str : in String;
Check : Boolean := True)
is
begin
Update (Item, Offset, To_C (Str), Check);
end Update;
-----------
-- Value --
-----------
function Value (Item : in Chars_Ptr) return Char_Array is
Result : Char_Array (0 .. Strlen (Item));
begin
if Item = Null_Ptr then
raise Null_Dereference;
end if;
-- Note that the following loop will also copy the terminating Nul
for J in Result'range loop
Result (J) := Peek (Item + J);
end loop;
return Result;
end Value;
function Value
(Item : in Chars_Ptr;
Length : in Natural)
return Char_Array
is
Result : Char_Array (0 .. Length - 1);
begin
if Item = Null_Ptr then
raise Null_Dereference;
end if;
for J in Result'range loop
Result (J) := Peek (Item + J);
if Result (J) = Nul then
return Result (0 .. J);
end if;
end loop;
return Result;
end Value;
function Value (Item : in Chars_Ptr) return String is
begin
return To_Ada (Value (Item));
end Value;
function Value (Item : in Chars_Ptr; Length : in Natural) return String is
begin
return To_Ada (Value (Item, Length));
end Value;
end Interfaces.C.Strings;